home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Struct < prev    next >
Encoding:
Text File  |  1995-12-06  |  22.9 KB  |  973 lines  |  [TEXT/MSET]
  1. \ Standard data structure classes
  2.  
  3. \ May  91        Added Longword
  4. \ June 91        Reimplemented ordered-col etc. using multiple inheritance
  5. \ May  92        Added obj_array
  6. \ July 92        Fixed OBJ: ObjHandle to use NPTR: instead of PTR:
  7. \                HandleArray now inherits from Obj_array.
  8. \ Dec 92        Replaced UGET: in Int and Byte with new classes UINT and UBYTE.
  9.  
  10. cr .( loading Struct...)
  11.  
  12. :class    LONGWORD  super{ object }    \ Generic superclass for var, handle etc.
  13.  
  14.     4    bytes    data
  15.  
  16. :m CLEAR:    inline{ 0 obj !}    0 ^base !  ;m
  17. :m GET:        inline{ obj @}        ^base @  ;m
  18. :m PUT:        inline{ obj !}        ^base !  ;m
  19. :m ->:        inline{ @ obj !}    chksame  @  put: self  ;m
  20.  
  21. :m PRINT:    ^base @  .  ;m
  22.  
  23. :m CLASSINIT:    clear: self  ;m
  24.  
  25. ;class
  26.  
  27.  
  28. :class    VAR  super{ longword }
  29.  
  30. :m +:        inline{ obj +!}    ^base +!   ;m
  31. :m -:        inline{ obj -!}    ^base -!   ;m
  32. ;class
  33.  
  34.  
  35. :class    INT    super{ object }
  36.  
  37.     2 bytes data
  38.  
  39. :m CLEAR:    inline{ 0 obj w!}    0 ^base w!  ;m
  40. :m GET:        inline{ obj w@x}    ^base w@x  ;m
  41. :m PUT:        inline{ obj w!}        ^base w!  ;m
  42. :m +:        inline{ obj w+!}    ^base w+!  ;m
  43. :m -:        inline{ obj w-!}    ^base w-!  ;m
  44. :m ->:        inline{ w@ obj w!}
  45.         chksame  w@  put: self  ;m
  46.  
  47. :m INT:        ^base w@  makeint  ;m    \ return as toolbox int
  48.  
  49. :m PRINT:    ^base w@x  .  ;m
  50.  
  51. :m CLASSINIT:    clear: self  ;m
  52.  
  53. ;class
  54.  
  55. :class  UINT  super{ int }
  56.  
  57. :m GET:    inline{ obj w@}  ^base w@  ;m
  58.  
  59. :m PRINT:    ^base w@  .  ;m
  60.  
  61. ;class
  62.  
  63.  
  64. :class    BYTE    super{ object }
  65.  
  66.     1 bytes data
  67.  
  68. :m CLEAR:    inline{ 0 obj c!}    0 ^base c!  ;m
  69. :m GET:        inline{ obj c@x}    ^base c@x  ;m
  70. :m PUT:        inline{ obj c!}        ^base c!  ;m
  71. :m ->:        inline{ c@ obj c!}    chksame  c@  put: self  ;m
  72.  
  73. :m PRINT:    ^base c@x  .  ;m
  74.  
  75. :m CLASSINIT:    clear: self  ;m
  76.  
  77. ;class
  78.  
  79.  
  80. :class  UBYTE  super{ byte }
  81.  
  82. :m GET:        inline{ obj c@}    ^base c@  ;m
  83.  
  84. :m PRINT:    ^base c@  .  ;m
  85.  
  86. ;class
  87.  
  88.  
  89. :class    BOOL    super{ byte }
  90.  
  91. :m PUT:        inline{ 0<> obj c!}        0<>  ^base c!  ;m
  92. :m SET:        inline{ true obj c!}    true  ^base c!  ;m
  93.  
  94. :m PRINT:    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m
  95.  
  96. ;class
  97.  
  98.  
  99. \ Handle class can store handles to relocatable heap blocks.
  100. \ It would be nice to store the length too, but this class is used
  101. \ for handles in toolbox records so we can't.  Not here at least.
  102.  
  103.     0    value    RELCNT        \ For testing - counts release: msgs
  104.                             \ to make sure we're releasing everything
  105.  
  106. :class    HANDLE    super{ longword }
  107.  
  108. :m PTR:        \ Dereferences handle to get pointer.  Trap if nil.
  109.     inline{ obj @ @}    ^base @ @  ;m
  110.  
  111. :m NPTR:        \ Dereferences handle and masks with SAmask so we can
  112.                 \ use the pointer numerically.
  113.     ^base @ @ SAmask and  ;m
  114.  
  115. :m RELEASE:        \ Deallocates the heap block, if allocated.
  116.     1 ++> relCnt  killH  ;m
  117.  
  118. :m CLEAR:    nilH  ^base !  ;m    \ We hope we know what we're doing.
  119.  
  120. :m NIL?:        \ ( -- b )
  121.     get: self  nilH =  ;m
  122.  
  123. :m SETSIZE:    \ ( size -- }
  124.     setHsz  0= ?error 166  ;m
  125.  
  126. :m SIZE:        \ ( -- size )  Gets current size.
  127.     getHSz  ;m
  128.  
  129. :m NEW:        \ ( size -- )
  130.     newH  0= ?error 166  ;m
  131.  
  132. :m LOCK:    lok    ;m
  133. :m UNLOCK:    unlok  ;m
  134.  
  135. :m GETSTATE:  ( -- state )    HgetSt  ;m
  136. :m SETSTATE:  ( state -- )    HsetSt  ;m
  137.  
  138. :m LOCKED?:   ( -- b )        HgetSt  $ 80 and  0<>  ;m
  139.  
  140. :m MOVEHI:    MvHHi  drop ( errors don't really matter here )  ;m
  141.  
  142. :m ->:        \ ( ^hdl -- )  Copies passed-in handle's heap data to self.
  143.     chkSame  copyH  ?error 167  ;m
  144.  
  145. :m PRINT:
  146.     & $ emit  ^base @  u.h  ;m    \ We assume a print: of a handle is more
  147.                                 \  useful in hex.
  148.  
  149. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  150.  
  151. ;class
  152.  
  153.  
  154. \ OBJHANDLE is a handle that points to an object in the heap.
  155.  
  156. :class    OBJHANDLE  super{ handle }
  157.  
  158. :m OBJ:        moveHi: self  lock: self  nptr: self  >obj  ;m
  159.  
  160.     \ Note: if we're going to bind to a heap-based object,
  161.     \ the handle MUST be locked while we do so - anything
  162.     \ may happen before the method returns!!  Thus we make the
  163.     \ obj: method do a moveHi and lock.  But remember to unlock
  164.     \ the handle eventually!  (Unless you're releasing it, of course.)
  165.  
  166. :m NEWOBJ:  ( #els ) { ^class -- }
  167.         \ Usage:  5  ['] someClass  newObj: someHndl
  168.  
  169.     ^class  cl>len  8 +  new: self
  170.     ^class  obj: self  make_obj  unlock: self  ;m
  171.  
  172. :m RELEASEOBJ:
  173.     nil?: self  ?EXIT
  174.     obj: self  release: []  release: super  ;m
  175.  
  176. :m RELEASE:    releaseObj: self  ;m        \ Standard destructor name.
  177.  
  178.     \ Note: we define both release: and releaseObj: so that in classes
  179.     \ HandleArray and HandleList we can distinguish between releasing the
  180.     \ current object and releasing the whole lot.  Release: is of course
  181.     \ overridden in those two classes to release the entire structure.
  182.  
  183. :m PRINT:
  184.     print: super  4 spaces  ." object: "
  185.     nil?: self
  186.     if    ." (none)"
  187.     else    print: [ obj: self ]  unlock: self
  188.     then   ;m
  189.  
  190. :m DUMP:
  191.     dump: super  cr
  192.     ." object: "
  193.     nil?: self
  194.     if    ." (none)"
  195.     else    dump: [ obj: self ]  unlock: self
  196.     then   ;m
  197.  
  198. ;class
  199.  
  200. :class    PTR     super{ longword }
  201.  
  202. :m RELEASE:        \ Deallocates the heap block, if allocated.
  203.     killP  ;m
  204.  
  205. :m NEW:   ( len -- )    newP  0= ?error 121  ;m
  206.  
  207. :m NIL?:   ( -- b )        ^base @  nilP =  ;m
  208.  
  209. :m CLEAR:    nilP  ^base !  ;m        \ We hope we know what we're doing.
  210.  
  211. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  212.  
  213. ;class
  214.  
  215.  
  216. \ DICADDR is a relocatable dictionary address class - use to store
  217. \ non-executable dictionary addresses.
  218.  
  219. :class     DICADDR  super{ longword }
  220.  
  221. :m GET:        ^base  @abs    ;m
  222. :m PUT:        ^base  reloc!    ;m
  223.  
  224. :m PRINT:    get: self  .id  ;m
  225.  
  226. :m CLASSINIT:    ['] null  put: self  ;m
  227.  
  228. ;class
  229.  
  230.  
  231. \ X-ADDR is an executable dictionary address class.  The only significant
  232. \ difference to DicAddr is that there is an Exec: method.
  233. \ But if we ever have to separate code and data, having a separate class
  234. \ could prove very useful.  An x-addr is the same as a Mops execution token.
  235.  
  236. :class    X-ADDR    super{ object }
  237.  
  238.     4    bytes    data
  239.  
  240. :m EXEC:    inline{ obj ex}    ^base @abs  execute  ;m
  241.  
  242. :m GET:        ^base  @abs    ;m
  243. :m PUT:        ^base  reloc!   ;m
  244.  
  245. :m CLASSINIT:    ['] null  put: self  ;m
  246.  
  247. ;class
  248.  
  249.  
  250. \        ============= Arrays ===============
  251.  
  252. : ?#XTS    \ ( n1 n2 -- )  Used to check that the right
  253.         \ number of stacked cfas is being passed in.
  254.     <>  ?error 171  ;    \ "Wrong number of cfas"
  255.  
  256.  
  257. \ Class INDEXED-OBJ is the generic superclass for all arrays.  Here we define
  258. \ the general indexed methods, which apply regardless of indexed width.
  259.  
  260. :class    INDEXED-OBJ  super{ object }
  261.  
  262. :m ^ELEM:    ^elem  ;m
  263.  
  264. :m LIMIT:    limit  ;m
  265.  
  266. :m WIDTH:    idxbase  6 -  w@  ;m
  267.  
  268. :m IXADDR:    idxbase  ;m
  269.  
  270. :m CLEARX:    \ Erases indexed area.
  271.     idxbase  limit  width: self  *  erase  ;m
  272.  
  273. ;class
  274.  
  275.  
  276. \ ARRAY is the basic 4-byte cell array.
  277.  
  278. :class    ARRAY  super{ indexed-obj }  4 indexed
  279.  
  280. :m AT:  ( index -- n )        inline{ ix @}    ^elem4  @    ;m
  281. :m TO:  ( n index -- )        inline{ ix !}    ^elem4  !    ;m
  282. :m +TO:  ( n index -- )        inline{ ix +!}    ^elem4  +!    ;m
  283. :m -TO:  ( n index -- )        inline{ ix -!}    ^elem4  -!    ;m
  284. :m ^ELEM:  ( idx -- addr )    inline{ ix}    ^elem4    ;m
  285.  
  286. :m FILL:        \ ( value -- )  Fills all elements with value.
  287.     idxbase  limit 4*  bounds
  288.     ?do  dup  i !  4 +loop  drop  ;m
  289.  
  290. :m WIDTH:    4  ;m        \ Faster than the default in Indexed-obj.
  291.  
  292. :m GETELEM:    \ ( addr -- n )  Fetches one element at addr - saves indexing
  293.         \        step if addr is known.
  294.     @  ;m
  295.  
  296. ;class
  297.  
  298.  
  299. \ X-ARRAY can execute its elements.
  300.  
  301. :class    X-ARRAY  super{ array }
  302.  
  303. :m TO:  ( index -- )    ^elem: super  reloc!  ;m
  304.  
  305. :m EXEC:  ( index -- )
  306.     inline{ ix ex}    ^elem: self  @abs  execute  ;m
  307.  
  308. :m FILL:        \ ( xt -- )
  309.     limit nif  drop  exit  then    \ Out if no elements
  310.     idxbase  tuck  reloc!    @  fill: super  ;m
  311.  
  312. :m PUT:            \ ( xt0 ... xt(N-1) N -- )
  313.     limit  0EXIT                \ Out if no elements
  314.     false -> relocChk?            \ May get used in instantiating exported objs
  315.     limit ?#xts
  316.     idxbase  dup  limit 1-  4*  +
  317.     do  i reloc!  -4 +loop
  318.     true -> relocChk?  ;m
  319.  
  320. :m ACTIONS:        \ A synonym for put:.  A more appropriate name to use in
  321.                 \ sub-classes such as dialogs.
  322.     put: self  ;m
  323.  
  324. private
  325.  
  326. :m PrintNxts:    \ ( n -- )
  327.     0 ?do  i ^elem: self  @abs  cr .id  loop  ;m
  328.  
  329. public
  330.  
  331. :m PRINT:        limit  printNxts: self  ;m
  332.  
  333. :m CLASSINIT:    ['] null  fill: self  ;m
  334.  
  335. ;class
  336.  
  337.  
  338. \ SEQUENCE is a generic superclass for classes which have multiple items which
  339. \ frequently need to be looked at in sequence.  At present the main function of
  340. \ Sequence is to implement the EACH: method, which makes it very simple to
  341. \ deal with each element.  The usage is
  342. \
  343. \    BEGIN  each: <obj>  WHILE  <do something to the element>  REPEAT
  344. \
  345. \ Sequence can be multiply inherited with any class which implements the
  346. \ FIRST?: and NEXT?: methods.  The actual implementation details are quite
  347. \ irrelevant, as long as these methods are supported.
  348.  
  349. \ But note that any class using Sequence should not appear in a record, since
  350. \ we must late bind to self, so a class pointer must be present.
  351.  
  352. :class    SEQUENCE    super{ object }        general
  353.  
  354. record
  355. {    var    NXT_XT
  356.     var    ^SELF
  357. }
  358.  
  359. :m EACH:        \ ( -- (varies) T  |  -- F )
  360.     get: nxt_xt
  361.     NIF                                \ First time in:
  362.         first?: [self]  0dup  0EXIT
  363.         self  bind_with next?:        \ Late-bind to next?: and cache
  364.         put: nxt_xt  put: ^self        \  the xt for the loop
  365.         true                        \ Yes, we've got the 1st element
  366.     ELSE                            \ Subsequent time in:
  367.         get: ^self  get: nxt_xt  ex-method        \ Call next?: method (cached)
  368.         IF  true  ELSE  clear: nxt_xt  false  THEN
  369.     THEN  ;m
  370.  
  371. :m UNEACH:    \ Use to terminate an EACH: loop before the end.
  372.     clear: nxt_xt  ;m
  373.  
  374. ;class
  375.  
  376.  
  377. 0    value    LASTSUP
  378. 0    value    LASTSUPADDR
  379.  
  380. : REMOVELASTSUPER  { ^class \ infa -- }
  381.     ^class ifa displace  -> infa
  382.     BEGIN  infa @ 0>  NWHILE  infa ^nextivar  -> infa
  383.     REPEAT
  384.     BEGIN
  385.         4 ++> infa
  386.         infa @
  387.     NUNTIL
  388.     4 --> infa
  389.     infa -> lastSupAddr
  390.     infa @  -> lastSup
  391.     0 infa !  ;
  392.             
  393. : RESTORELASTSUPER
  394.     lastSup lastSupAddr !  ;
  395.  
  396.  
  397. \ OBJ_ARRAY is a generic superclass which makes it easy to generate an array
  398. \ of objects of a given class.  Just define a new class which multiply
  399. \ inherits from the given class (or classes) and OBJ_ARRAY (which must come
  400. \ last).  This will add an indexed section to each object of the new class,
  401. \ with elements wide enough to contain objects of the original class.  Then
  402. \ SELECT: "switches in" the selected element to be the "current" element,
  403. \ and all the normal methods  of the class can then be used.
  404. \ The implementation is general rather than brilliantly fast.  If switching
  405. \ between elements is really a performance concern, you could override
  406. \ SELECT: - especially if you know the element width.  But note, we do
  407. \ assume the elements are aligned.
  408.  
  409. :class  OBJ_ARRAY  super{ indexed-obj sequence }    32767 indexed
  410.             \ The 32767 signals that the real indexed width is to be
  411.             \  taken from the other superclass(es).
  412.  
  413. record{  int  CURRENT  }
  414.  
  415. :m CURRENT:
  416.     get: current  ;m
  417.  
  418. :m SELECT:  { idx \ datalen slf -- }
  419.     idx  get: current =  ?EXIT                        \ out if nothing to do
  420.     width: self  -> datalen   self -> slf            \ set up
  421.     slf  get: current  ^elem  datalen  aligned_move    \ switch out previous
  422.     idx  put: current
  423.     idx ^elem  slf  datalen  aligned_move  ;m        \ switch in new
  424.  
  425. :m FIRST?:
  426.     limit NIF  false  EXIT  THEN
  427.     0  select: self  true  ;m
  428.  
  429. :m NEXT?:
  430.     get: current 1+  limit  >=  IF  false  EXIT  THEN
  431.     get: current 1+  select: self  true  ;m
  432.     
  433.  
  434. :m PRINTALL:    \ Sends PRINT: to all elements
  435.     get: current
  436.     BEGIN  each: self  WHILE  print: [self]  REPEAT
  437.     select: self  ;m
  438.  
  439. (*
  440. We need to initialize all the elements.  Element 0 has been initialized
  441. already, by the time we get classinit: sent here, since we're the last
  442. superclass.  We could select each element and send deep_classinit:, but
  443. it's a bit tricky getting the right class to use.  Instead we'll just
  444. copy element 0 to the other elements, which will usually be good enough.
  445. *)
  446.  
  447. :m CLASSINIT:  { \ dln slf -- }
  448.     width: self  -> dln   self -> slf            \ set up
  449.     limit  1        \ note: elt 0 has had classinit: already!
  450.     ?DO
  451.            slf  i ^elem  dln  aligned_move
  452.     LOOP
  453. ;m
  454.  
  455. ;class
  456.  
  457.  
  458. \ (PHlist) is a superclass for HandleList and PtrList, mainly aimed at
  459. \ factoring out common code.  It's really only meant for internal use.
  460.  
  461. :class (PHlist)  super{ sequence }
  462.  
  463. record
  464. {    handle    THELIST
  465.     var        SIZE
  466.     var        POS
  467. }
  468.  
  469. private
  470.  
  471. :m  (SEL):    \ ( n -- )  n is offset into theList, NOT an index.
  472.     self @  ptr: theList  get: pos +  !        \ switch out previous
  473.     put: pos
  474.     ptr: theList  get: pos  +  @  self !    \ switch in new
  475. ;m
  476.  
  477. public
  478.  
  479. :m ADD:  { addMe \ whr ^class -- }
  480.     get: size  -> whr
  481.     whr
  482.     NIF    nil?: theList
  483.         IF        80  new: theList        \ Give it room to play with
  484.         ELSE    80  setsize: theList
  485.         THEN
  486.     THEN
  487.     whr cell+  dup  setsize: theList  put: size
  488.     whr  (sel): self
  489.     addMe  self !
  490. ;m
  491.  
  492.  
  493. :m REMOVE:  { \ whr cnt -- }        \ Completely removes the current element.
  494.     ptr: theList  get: pos  +  -> whr
  495.     1cell  -: size  get: size  get: pos  -  -> cnt
  496.     cnt IF  whr cell+  whr  cnt  move  THEN
  497.                     \ note: can't use aligned_move since it's a move down,
  498.                     \ and overlaps
  499.     get: pos  cell-  0 max  put: pos
  500.     ptr: theList  get: pos  +
  501.     ptr: theList  get: pos  +  @  self !    \ switch in new current elt
  502.     get: size  NIF  release: theList  THEN  ;m
  503.  
  504.  
  505. :m SELECT:    \ ( n -- )
  506.     4*  0  get: size cell-  within? not  ?error 134
  507.     (sel): self  ;m
  508.  
  509. :m SELECTLAST:
  510.     get: size  cell-  (sel): self  ;m
  511.  
  512. :m CURRENT:    get: pos  4/  ;m
  513.  
  514. :m SIZE:    get: size 4/  ;m
  515.  
  516. \ The next two methods are needed by EACH:, but may be called directly as well.
  517. \ Note that NEXT?:  ASSUMES that the list is allocated in the heap and that a
  518. \ valid element is selected as the current element.  EACH: ensures this,
  519. \ since if FIRST?: returns false, NEXT?: is never called.  But if you call
  520. \ it directly, make sure this condition holds.
  521.  
  522. :m FIRST?:    \ ( -- n T | -- F )
  523.     nil?: theList  IF  false  EXIT  THEN
  524.     0 (sel): self  self @  true  ;m
  525.  
  526. :m NEXT?:  { \ nxt -- n T | -- F }
  527.     get: pos  cell+  -> nxt
  528.     nxt  get: size  >= IF  false  EXIT  THEN
  529.     nxt (sel): self  self @  true  ;m
  530.  
  531.  
  532. :m DUMPALL:
  533.     nil?: theList IF  ." (not open)"  EXIT  THEN
  534.     dump: super  cr  ." current: "  current: self  dup .
  535.     cr ." elements: "  cr
  536.     BEGIN  each: [self]  WHILE  dump: [self]  REPEAT
  537.     select: self  ;m
  538.  
  539. :m PRINTALL:
  540.     nil?: theList IF  ." (not open)"  EXIT  THEN
  541.     get: pos
  542.     BEGIN  each: self  WHILE  print: [self]  cr  REPEAT
  543.     (sel): self  ;m
  544.  
  545. ;class
  546.  
  547.  
  548. \ HANDLEARRAY and HANDLELIST are for the implementation of collections
  549. \ of heap-based objects.  HandleArray has normal array properties, and
  550. \ thus a definite length.  HandleList, however, allows the number of
  551. \ elements to grow arbitrarily large.  Use HandleList if you need an
  552. \ indefinite number of elements, and if indexing isn't so important.
  553. \ HandleArray also includes methods to allow the array to be used as a
  554. \ stack - needed for FileList.
  555.  
  556. :class    HANDLEARRAY  super{ objHandle  array  obj_array }
  557.  
  558. record
  559. {    int    size  }
  560.  
  561. :m SIZE:        get: size  ;m
  562. :m SETSIZE:        put: size  ;m
  563.  
  564. :m RELEASE:
  565.     get: size  0  ?DO
  566.         i select: self  releaseObj: self
  567.     LOOP  ;m
  568.  
  569. :m PUSH:        \ ( hdl -- )
  570.     get: size  limit  >=  ?error 137
  571.     get: size  select: self  1 +: size
  572.     put: super  ;m
  573.  
  574. private
  575. :m (TOP):
  576.     get: size  dup
  577.     IF    1-  select: self
  578.     ELSE    drop  clear: current
  579.     THEN  ;m
  580. public
  581.  
  582. :m TOP:
  583.     get: size  0= ?error 136  (top): self  ;m
  584.  
  585. :m DROP:
  586.     get: size  dup  0= ?error 136
  587.     1-  select: self  releaseObj: self
  588.     1 -: size  (top): self  ;m
  589.  
  590. :m PUSHNEWOBJ:
  591.     0 push: self  newObj: self  ;m
  592.  
  593. :m CLEARX:    nilH  fill: self  ;m
  594.  
  595. :m  CLASSINIT:    clearX: self  clear: self  ;m
  596.  
  597. ;class
  598.  
  599.  
  600. \ HANDLELIST allows the implementation of a list of heap-based objects.
  601. \ Unlike HANDLEARRAY, the list can be of indefinite length.  We use a heap
  602. \ block to store the handles to the objects contiguously, rather than have
  603. \ a separate block for each handle and link them together.  This saves on
  604. \ memory overhead and reduces the number of memory manager calls.  It also
  605. \ reflects the assumption that insertions and deletions into the middle of
  606. \ the list will be infrequent, as these could be more inefficient than with
  607. \ a linked scheme.  We expect that elements will normally be added to the
  608. \ end, and probably not removed at all, or not very often.
  609.  
  610.  
  611. :class  HANDLELIST  super{ objHandle (PHlist) }
  612.  
  613. \ FIRST?: and NEXT?:, needed for the EACH: construction, are overridden here
  614. \ since if the next element exists we return the object address as well as
  615. \ the True.  We also need to unlock the previous objHandle when we step
  616. \ to the next one.
  617.  
  618. :m SIZE:    \ We're overriding here since objHandle has a size: method
  619.             \  which isn't really useful here
  620.     size: super> (PHlist)  ;m
  621.  
  622. :m FIRST?:    \ ( -- ^obj T | -- F )
  623.     first?: super  NIF  false  EXIT  THEN
  624.     drop  obj: self  true  ;m
  625.  
  626. :m NEXT?:  { \ nxt -- ^obj T | -- F }
  627.     unlock: super
  628.     next?: super  NIF  false  EXIT  THEN
  629.     drop  obj: self  true  ;m
  630.  
  631.  
  632. :m NEWOBJ:    \ ( ^class -- )
  633.     nilH  add: super> (PHlist)
  634.     newObj: super  ;m
  635.  
  636. :m REMOVEOBJ:            \ Completely removes the current element.
  637.     releaseObj: super  remove: super  ;m
  638.  
  639. :m RELEASE:
  640.     BEGIN  each: self  WHILE  drop  releaseObj: super  REPEAT
  641.     release: theList
  642.     clear: pos  clear: size  ;m
  643.  
  644. :m DUMPALL:
  645.     nil?: theList if  ." (not open)"  EXIT  THEN
  646.     dump: super  cr  ." current: "  get: pos  dup 4/ .
  647.     cr ." elements: "  cr
  648.     BEGIN  each: self  WHILE  dump: []  REPEAT
  649.     (sel): self   ;m
  650.  
  651. :m PRINTALL:
  652.     nil?: theList if  ." (not open)"  EXIT  THEN
  653.     get: pos
  654.     BEGIN  each: self  WHILE  print: []  cr  REPEAT
  655.     (sel): self  ;m
  656.     
  657. ;class
  658.  
  659.  
  660. :class PTRLIST  super{ ptr (PHlist) }
  661.  
  662. ;class
  663.  
  664.  
  665. \            ============== Collections ================
  666.  
  667. \ Collections are ordered lists with a current size.  We implement them by
  668. \ multiply inheriting the generic (COL) class with the array class of the
  669. \ appropriate width.  We use a few tricks to avoid late binding to self
  670. \ in loops.
  671.  
  672. :class    (COL)  super{ object }
  673.  
  674. record
  675. {    int    SIZE    }            \ # elements in list
  676.  
  677. :m SIZE:    \ ( -- cursize )  Returns #elements currently in list
  678.      inline{ get: size}  get: size  ;m
  679.  
  680. :m CLEAR:    \ Set to list to null
  681.     clear: size   clearx: [self]  ;m
  682.  
  683. :m ADD:        \ ( val -- )  add value to end of list
  684.     get: size  limit  >=  ?error 137
  685.     get: size  to: [self]  1 +: size  ;m
  686.  
  687. :m LAST:        \ ( -- val )  Returns contents of end of list
  688.     get: size  dup 0=  ?error 136
  689.     1-  at: [self]  ;m
  690.  
  691. :m REMOVE:  { indx \ cnt wid addr -- }    \ Removes the element at index
  692.     get: size  indx -  1-  -> cnt
  693.     cnt 0<  ?error 136
  694.     width: [self]  -> wid
  695.     indx  ^elem: [self]  -> addr
  696.     1 -: size
  697.     cnt  0exit
  698.     addr wid +  addr  cnt wid *  move  ;m
  699.  
  700. :m INDEXOF:  { val \ ^self ^getelem wid addr -- indx T  | -- F }
  701.                 \ Finds a value in a collection.
  702.     self  bind_with getelem:  -> ^getelem  -> ^self
  703.     width: [self]  -> wid  idxbase -> addr
  704.     false  get: size  0
  705.     ?do
  706.         addr  ^self ^getelem  ex-method
  707.         val =  if  drop  i  true  leave  then
  708.         wid ++> addr
  709.     loop  ;m
  710.  
  711. :m PRINT:
  712.     get: size  0  ?do  i  at: [self]  cr .  loop  ;m
  713.  
  714. :m DUMP:
  715.     dump: super  ." size: "  get: size .  ;m
  716.  
  717. ;class
  718.  
  719.  
  720. \ Ordered-Collection is a collection of 4-byte cells.
  721.  
  722. :class    ORDERED-COL    super{ (col) array }
  723. ;class                        \ That's all, folks!!
  724.  
  725.  
  726. \ X-COL is a collection of execution tokens.
  727.  
  728. :class    X-COL    super{  (col)  x-array  }
  729.  
  730. :m  REMOVEXT:    \ ( xt -- )
  731.     false -> relocChk?  pad reloc!  true -> relocChk?
  732.     pad @  indexof: self  0EXIT
  733.     remove: self  ;m
  734.  
  735. :m  PRINT:
  736.     get: size  printNXts: self  ;m
  737.  
  738. ;class
  739.  
  740.  
  741.  
  742.  
  743. :class    DIC-MARK    super{ object }
  744.  
  745. #threads    array    LINKS
  746. record {    int        CURRENT    }
  747.  
  748. private
  749.  
  750. :m  SETC:  { \ addr index -- index }
  751.     0 -> addr  0 -> index
  752.     #threads FOR
  753.         i at: links  dup addr u>
  754.         IF  -> addr  i -> index  ELSE  drop  THEN
  755.     NEXT
  756.     index  put: current  ;m
  757. public
  758.  
  759. :m CURRENT:
  760.     get: current  at: links  ;m
  761.  
  762. :m SET:  { addr -- }
  763.     #threads FOR
  764.         context  i  2 <<  +  displace
  765.         BEGIN    dup addr u>            \ We're 32-bit clean around here!
  766.         WHILE    displace
  767.         REPEAT
  768.         i to: links
  769.     NEXT
  770.     setc: self  ;m
  771.  
  772. :m SETTOTOP:    big#  set: self  ;m
  773.  
  774. :m NEXT:  { \ lfa -- lfa }
  775.     get: current  at: links
  776.     dup -> lfa  dup  0EXIT
  777.     displace  get: current  to: links
  778.     setc: self  lfa  ;m
  779.  
  780. ;class
  781.  
  782. dic-mark    TheMARK
  783.  
  784.  
  785. \         ========== Resource support ===========
  786.  
  787. :class    RESOURCE  super{ handle }
  788.  
  789. record
  790. {    var    RESTYPE
  791.     int    ID
  792. }
  793.  
  794. :m SET:        \ ( type id# -- )
  795.     put: ID  put: resType   ;m
  796.  
  797. :m GETNEW:
  798.     get: resType  get: ID  getRes  dup
  799.     NIF                            \ Failed - display type and ID
  800.         cr  addr: resType  4  type  2 spaces
  801.         get: ID  .  170 die        \ Couldn't find this resource
  802.     THEN
  803.     put: super  ;m
  804.  
  805. :m GETXSTR:  { idx \ addr -- addr len }
  806.     getnew: self
  807.     ptr: self  -> addr
  808.     addr w@ 1-  idx min  -> idx
  809.     2 ++> addr
  810.     idx 0 ?DO  addr count +  -> addr  LOOP
  811.     addr count   ;m
  812.  
  813. ;class
  814.  
  815. \                ====================================
  816.  
  817. \                        SOME UTILITY WORDS
  818.  
  819. \                ====================================
  820.  
  821. \ Any special run-time initialization can be done conveniently by adding
  822. \ the appropriate words to the x-col INIT_ACTIONS.  These words will be
  823. \ executed on startup via EXTRA_INITS, right after OBJINIT.
  824.  
  825.     8    x-col    INIT_ACTIONS
  826.  
  827. : X        size: init_actions  0  ?DO  i exec: init_actions  LOOP  ;
  828.  
  829. ' x  -> extra_inits
  830.  
  831.  
  832. : SCREENBITS    \ ( -- l t r b )
  833.                 \ Gets dimension coordinates of host machine's display.
  834.     $ 904 @ @  116 -        \ **** warning - low mem global ref'd
  835.     dup    @ unpack
  836.     rot 4+ @ unpack  ;
  837.  
  838.  
  839. : CHKKEY
  840.     cr     type# 189            \ "paused - <space> to continue..."
  841.     cr                        \ 01Feb94 DBH  Add cr.  Better for TW.
  842.     (key)  cr  0 -> out  bl =  nif  cr decimal abort  then  ;
  843.  
  844.  
  845. : ?P
  846.     sleepticks  0 -> sleepticks
  847.     ?terminal
  848.     swap -> sleepticks
  849.     NIF  pause  EXIT  THEN        \ No key hit - just do default PAUSE
  850.     (key) drop  chkKey  ;
  851.  
  852. : P
  853.     sleepticks  0 -> sleepticks
  854.     ?terminal  drop
  855.     -> sleepticks  ;
  856.  
  857. ' p        -> pause            \ This will be improved when Events is loaded
  858. ' ?p    -> ?pause
  859.  
  860.  
  861. : WORDS  { \ svbase svcurs n -- }
  862.     setToTop: theMark  0 -> out  0 -> n
  863.     base -> svbase  hex  curs -> svcurs  -curs  cr
  864.     BEGIN
  865.         next: theMark
  866.         ?dup
  867.     WHILE
  868.         1 ++> n
  869.         out 60 >
  870.         if  cr  0 -> out  ?pause  then
  871.         link> dup  6 .r  2 spaces  .id  space
  872.         20  out 20 mod -  spaces
  873.     REPEAT
  874.     svbase -> base
  875.     cr ." No of words: "  n .  cr
  876.     svcurs -> curs  ;
  877.  
  878.  
  879. false    value    ENDTRAV?    \ May be set from within a trav handler
  880.                 \ to terminate the trav
  881.  
  882. : (TRAV)  { theWord parm -- }
  883.     false -> endTrav?
  884.     BEGIN
  885.         next: theMark
  886.         ?dup  0EXIT
  887.         link>  parm  theWord execute
  888.         endTrav?
  889.     UNTIL  ;
  890.  
  891. : TRAV    \ ( xt parm -- )
  892.         \ Traverses the dictionary, passing each xt and the parm
  893.         \ to the passed-in proc.
  894.  
  895.     setToTop: theMark  (trav)  ;
  896.  
  897. : TRAV-FROM    \ ( xt parm addr -- )
  898.             \ As for TRAV, but starts from the first word whose lfa is
  899.             \ below or at the given address.
  900.  
  901.     set: theMark  (trav)  ;
  902.  
  903.  
  904. \                =============== Dump ==================
  905.  
  906. \ This used to be in the Util module.  But sometimes the loading of that
  907. \ module could cause the address of what we wanted to dump to change.
  908.  
  909.     0    value    DUMPADDR
  910.     0    value    DUMPLEN
  911.  
  912. : U.R
  913.     >r 0 <# #s #>  r> over - spaces  type  ;
  914.  
  915. : dot4    0 <#  # # # #  #>    type  space  ;
  916.  
  917. : D.4    ( addr len -- )  bounds do  i w@  dot4  2 +loop  ;
  918.  
  919. : EMIT.        \ ( c -- )
  920.     127 and  bl 126 within?  nif  drop  & .  then  emit  ;
  921.  
  922. : DLN        \ ( addr -- )
  923.     cr  dup  8 u.r  2 spaces
  924.     dup ( addr )  8 2dup d.4 space  +  8 d.4 space
  925.     16  bounds DO  i c@ emit.  LOOP  ;
  926.  
  927.  
  928. : ?.N        \ ( n1 n2 -- n1 )
  929.     2dup = if  ." \/"  drop  else  1 .r space  then  ;
  930.  
  931. : ?.A        \ ( n1 n2 -- n1 )
  932.     2dup = if  drop  & V  emit  else  1 .r  then  ;
  933.  
  934. : .HEAD        \ ( addr len -- addr' len' )
  935.     swap  dup -16 and  swap 15 and  cr  10 spaces
  936.      8 0 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  937.     16 8 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  938.     16 0 DO  i ?.a  LOOP   rot +  ;
  939.  
  940. :f DUMP  { addr len \ svBase svCurs -- }
  941.     base -> svBase  hex  curs -> svCurs  -curs
  942.     addr len  .head
  943.     2dup  -> dumpLen  -> dumpAddr        \ Save for DN
  944.     bounds  DO  i dln  ?pause  16 +LOOP  cr
  945.     svbase -> base  svCurs -> curs  ;f
  946.  
  947. : DN        \ Dump next
  948.     dumpLen ++> dumpAddr  dumpAddr dumpLen dump  ;
  949.  
  950. : .W    '  >name 200 dump  ;
  951.  
  952.  
  953. <" String
  954.  
  955. \ Testing:
  956.  
  957. +echo
  958.  
  959. :class VArr super{ var obj_array }
  960. ;class
  961.  
  962. 6 varr OA
  963.  
  964. handleList HL
  965.  
  966. key!
  967.  
  968. : h1 ." hello"  ;
  969. : h2 ." hi there!"  ;
  970.  
  971. 3 x-array xx
  972. xts{ h1 h2 h1 } put: xx
  973.